;;##########################################################################
;; systmobj.lsp
;; Copyright (c) 1991-2001 by Forrest W. Young
;; defproto, isnew and slot accessors for ViSta system object
;;##########################################################################
 
(defproto vista-system-object-proto 
  '(
    var-window-object        obs-window-object      varobs-container-object 
    mat-window-object        cells-window-object    help-window-object expert
    guidemap                 guidemap-name          guidemap-number
    need-new-guidemap        guidemap-slots         long-menus
    button-down              delay-update           delay-return 
    profiles                 instant-return
    vis-window-status        help-window-status     full-screen
    workmap-size             workmap-location 
    datasheet-size           datasheet-location 
    datasheet-list           spreadplot-list
    expert-window-size       expert-window-location 
    guide-window-size        guide-window-location 
    desktop-size             desktop-location
    spreadplot-size          spreadplot-location
    spreadplot-sizes         datasheet-sizes    
    help-layout-sizeloc      pre-menu-help-menu-item-states 
    workmap-layout-sizeloc   pre-menu-help-menu-states
    show-guidemap            hide-workmap 
    show-toolbar             show-varobs
    report-window-id-list    vars-showing            obs-showing
    show-listener            show-open-data          show-long-menus
    show-flying-logo         missing-values          show-load-vista
    redraw-active            postponed-redraw-list   menu-states
    background-color         color-values-list       configure
    applet-name show-help    show-first-help         directory-list
    show-menu-help-again     help-showing            show-welcome
    internal-map applets     normalsize              save-desktop 
    plugins plugin-dialog    plugin-data-types       previous-plugins
    workmap-proportion       sob-names data-args     font
    plugin-model-prefix      plugin-ok-variable-types
    plugin-menu-item-titles  analysis-menu-item-titles
    data-object-list         initial-spin exit-style
    frames-per-second        reuse-help-windows
    screen-saver-full-screen screen-saver-on 
    screen-saver-time        screen-saver-clock
    click-to-close           always-on-top
    fit-window-to-text?))

(defmeth vista-system-object-proto :isnew ()
  (let ((var-window)
        (obs-window)
        (var-menu)
        (obs-menu)
        (varobs-obj)
        )
    (setf *vista* self)
    (when *full-screen* (send self :full-screen t))
    (send self :expert nil)
    (send self :guidemap nil)
    (send self :guidemap-name "load-dat")
    (send self :vis-window-status nil)
    (send self :help-window-object nil)
    (send self :help-window-status nil)
    (send self :need-new-guidemap t)
    (setf *varobs-obj* 
          (double-name-list nil nil 
                            :style (if *seamless-desktop* 1 7)
                            :putin-this-container *desktop-container* 
                            :show nil :title "Selector"
                            :list-titles (list "Observations" "Variables")))
    (setf *selector* *varobs-obj*)
    (setf obs-window (send *varobs-obj* :list1))
    (setf var-window (send *varobs-obj* :list2))
    (setf *obs-window* obs-window )
    (setf *var-window* var-window )


    (defmeth *obs-window* :linked (&optional (link-state nil set))
      "Message args: (&optional link-state)
Sets or retrieves whether linking is on for the observation list window."
      (unless (send self :has-slot 'linked)
              (send self :add-slot 'linked))
      (if set (setf (slot-value 'linked) link-state))
      (slot-value 'linked))
  
    (defmeth *obs-window* :links ()
      (cond
        ((or (not $) (not (equal $ @))) nil)
        ((send self :linked) (send (send self :data-object) :links))
        (t nil)))
  
    (defmeth *obs-window* :data-object ()
      (if (equal @ $) $ nil))


    (defmeth *varobs-obj* :plot-help ()
      (plot-help-window "Help for The Selector")
      (paste-plot-help (format nil 
"The SELECTOR displays lists of the observations and variables in the currently active data object (when there is one). You can select items in these lists to form a subset of ACTIVE observations and variables.~2%ACTIVE variables and observations are those which are highlighted, or if none are highlighted, those which are listed.~2%"))
      (paste-plot-help (format nil 
"Only the ACTIVE variables are used in ViSta's analyses and visualizations.~2%You can create a new data object containing only the ACTIVE observations and variables with the DATA menu's CREATE DATA menu item.~2%"))
      (paste-plot-help (format nil 
"You make a SELECTOR item ACTIVE by clicking it. You can select several items by dragging your cursor over them. You can add items to a selection by CTRL-clicking, or CTRL-dragging.~2%"))
      (paste-plot-help (format nil 
"You form a selection with the buttons at the top of the SELECTOR. These buttons let you put data items IN the selection or take them OUT of the selection. You can also DROP a selection or RESET all data items to the selection. You can also use the selector's popup menu to make the selection.~2%"))  
      (show-plot-help))

    (send self :var-window-object var-window)
    (send self :obs-window-object obs-window)
    (send self :mat-window-object obs-window)
    (send self :cells-window-object obs-window)
    #|fwy changed june 4 2000. initialization is now in maketime/defvar.lsp
    (send self :plugins (list "ANOVA" "Coresp" "MDScal" "MulReg" "PrnCmp" "Regres" "UniVar"))
    (send self :plugin-menu-item-titles (list "Analysis of Variance" "Correspondence Analysis" "Multidimensional Scaling" "Multivariate Regression" "Principal Components" "Regression Analysis" "Univariate Analysis"))
    (send self :plugin-data-types 
          (list (list "class" "multivariate")     ;ANOVA  "class" "multivariate"
                (list "freq")  ;CORESP "freq" "class" "category" "multivariate"
                (list "matrix")                   ;MDSCAL "matrix" "multivariate"
                (list "multivariate")             ;MulReg
                (list "multivariate" "bivariate") ;PrnCmp "matrix" "multivariate"
                (list "multivariate" "bivariate") ;Regres
                (list "multivariate" "univariate" "bivariate" "class");UniVar
                ))
|#
    (send self :plugins *initial-button-names*)
    (send self :plugin-menu-item-titles *initial-analysis-menu-items*)
    (send self :plugin-data-types *initial-analysis-datatypes*)
    (send *toolbox* :data-types-master (send self :plugin-data-types))
    (send *toolbox* :analyze-menu-item-name-master 
          (send self :plugin-menu-item-titles))
    
    (send self :menu-states "Disabled")
    (send self :workmap-proportion .5)
    (send self :workmap-size screen-size)
    (make-minmax-desktop-sizes (if *full-screen* 0 1))
    (send self :background-color t)
    (send self :color-values-list 
          (list *workmap-background* *toolbar-background* *data-icon-color* 
                *model-icon-color* *tool-icon-color* *guide-icon-color* 
                *button-on-color* *button-off-color*))
    )) 


(defmeth vista-system-object-proto :make-watcher 
  (&key (show nil) (size (list 250 15)) (location (list 100 100)) 
        (sub-title ""))
  (let* ((width 250)
         (x (- (first (screen-size)) width)))
    (setf *watcher* 
          (info-window (format nil " ") :title "Please Wait" :show show
                       :size size :location location))
    (send *watcher* :add-slot 'time 0)
    (defmeth *watcher* :time (&optional (val nil set))
      (if set (setf (slot-value 'time) val))
      (slot-value 'time))

    (defmeth *watcher* :write-text (text &key (show t))
      (when (= 0 (send self :time)) (send self :time (run-time)))
      (if (> (- (run-time) (send self :time)) .1)
          (send *desktop-container* :title 
                (strcat "ViSta - The Visual Statistics System. (" text ")"))))
	
    (send *watcher* :location 2000 2000)
    (defmeth *watcher*  :close ()
      (send self :time 0) 
      (setf sub-title (if (> (run-time) 1.00) "" *copyright-string*))
      (send *desktop-container* :title 
                (strcat "ViSta - The Visual Statistics System.  " sub-title))
      )
    (defmeth *watcher*  :hide-window ()
      (setf sub-title (if (> (run-time) 1.00) "" *copyright-string*))
      (send *desktop-container* :title 
                (strcat "ViSta - The Visual Statistics System.  "sub-title))
      )
    (defmeth *watcher* :set-timer ()
      (send self :time (run-time)))
    (defmeth *watcher*  :show-window ()
      (send self :time (run-time))
      (setf sub-title (if (> (run-time) 1.00) "" *copyright-string*))
      (send *desktop-container* :title 
                (strcat "ViSta - The Visual Statistics System.  "sub-title))
      )
    *watcher*))


(defmeth vista-system-object-proto :check-running-system-processes (x y m1 m2 w)
  (when (send *vista* :show-help)
        (send *vista* :turn-menu-help-off x y m1 m2 w t))
  (when (send *vista* :screen-saver-on)
        (when *screen-saver*
              (if (send *screen-saver* :showing)
                  (send *workmap* :hide-screen-saver)
                  (send *workmap* :reset-screen-saver))))
  )
  
  
(defmeth vista-system-object-proto :turn-menu-help-off (x y m1 m2 w no-help-msg?)
  (one-liner "TURNING MENU HELP OFF"  :show-time 1 :location (list x y))
  (send *vista* :set-menu-help-mode no-help-msg?)
  (send w :do-click x y m1 m2))

(defmeth vista-system-object-proto :remove-dash-menu-items (menu)
  (let* ((menu-item-list (copy-list (send menu :items)))
         (menu-item-proto-list 
          (combine (mapcar #'(lambda (item) (send item :parents)) menu-item-list)))
         (dash-positions (positions dash-item-proto menu-item-proto-list))
         (item-positions 
          (remove-elements dash-positions (iseq (length menu-item-list)))))
    (select menu-item-list item-positions)))

(defmeth vista-system-object-proto :set-obs-mats-states (w)
  (if (send current-data :matrices)
          (send current-data :mat-states 
                (send w :point-state (iseq (send w :num-points))))
          (send current-data :obs-states
                (send w :point-state (iseq (send w :num-points))))))

(defmeth vista-system-object-proto :show-labels ()
  (let ((n (send current-data :nvar))
        (w (send self :var-window-object))
        )
#+msdos(send w :clear)
#-msdos(send w :clear :draw nil)
    (send w :add-points n :draw nil :point-labels
          (mapcar #'concatenate (repeat 'string n) 
                  (send current-data :variables) 
                  (repeat " (" n) (send current-data :types) 
                  (repeat ")" n)))
    (send w :point-state (iseq n) (send current-data :var-states))
    (send w :fix-name-list)
    (send w :scroll 0 0)
    (send w :redraw)
    ))

;modified by PV to use the new linking system
(defmeth vista-system-object-proto :show-obs ()
  (let* ((n (send current-data :nobs))
         (w (send self :obs-window-object))
         (m (send w :menu)))
#+msdos(send w :clear)
#-msdos(send w :clear :draw nil)
    (when (not (send current-data :has-slot 'linked-graph)) 
          (send current-data :record-linking-info)) 
    ;starts with the new record-linking system. I have tried to include this message in the ; :isnew method of mv-data-object but it does not startup. This is a kludge on a kludge.
 
    (setf obswindow-linked (send *obs-window* :linked))
    (send *obs-window* :linked nil)
    (send w :title "Obs")
    (send w :add-points n :draw nil :point-labels (send current-data :labels))
    (print current-data)
    ;(send w :point-state (iseq n) (send current-data :obs-states))
    (send w :point-state (iseq n) (send current-data :point-state (iseq n)))
    (send w :point-color (iseq n) (send current-data :point-color (iseq n)))
    (send w :point-symbol (iseq n) (send current-data :point-symbol (iseq n)))
    (send w :fix-name-list)
    (send w :scroll 0 0)
    (send *obs-window* :linked obswindow-linked)
    (send w :redraw)
    ))   

(defmeth vista-system-object-proto :show-mats ()
  (let* ((n (send current-data :nmat))
         (w (send self :mat-window-object))
         (m (send w :menu)))
#+msdos(send w :clear)
#-msdos(send w :clear :draw nil)
    (send w :title "Mats")
    (send w :add-points n :draw nil 
            :point-labels (send current-data :matrices))
    (send w :point-state (iseq n) (send current-data :mat-states))
    (send w :fix-name-list)
    (send w :scroll 0 0)
    (send w :redraw)
    ))

(defmeth vista-system-object-proto :show-cells ()
  (let* ((n (send current-data :ncells))
         (w (send self :cells-window-object))
         (m (send w :menu)))
#+msdos(send w :clear)
#-msdos(send w :clear :draw nil)
    (send w :title "Cells")
    (send w :add-points n :draw nil 
            :point-labels (send current-data :labels))
    (send w :fix-name-list)
    (send w :scroll 0 0)
    (send w :redraw)
    ))

(defmeth vista-system-object-proto :store-slot-info (slot-list)
  (send self :guidemap-slots 
        (append (send self :guidemap-slots) slot-list)))

(defmeth vista-system-object-proto :store-return-info 
  (instant-return guidemap-number)
  (if (not guidemap-number)
      (send self :instant-return
            (append (send self :instant-return) (list instant-return)))
      (setf (select (send *vista* :instant-return) guidemap-number) 
             instant-return)))

(defmeth vista-system-object-proto :show-vista ()
  (send vista-system-object-proto :new))

(defun vista-system ()
  (send vista-system-object-proto :new))

(defmeth vista-system-object-proto :create-message-window 
  (&key (title "Text Window") (size '(300 75)) 
             (location (list 100 (- (second *now-screen-size*) 200)))
        (show t))
  (let ((w (send display-window-proto2 :new 
                 :show show :size size :location location :title title)))
    (apply #'send w :frame-size size)
    (defmeth w :remove ()
      (send self :hide-window))
    w))


(defmeth vista-system-object-proto :prepare-to-show-vista ()        
  (send *desktop-window-menu* :remove)
  (send *selector* :show-window)
  (case *desktop-layout-state*
    (3 (restore-desktop))
    (2 (maximize-listener))
    (1 (maximize-datasheet))
    (0 (maximize-workmap)))
  (send *selector* :top-most T)
  (send *selector* :bottom-most NIL)
  (send *workmap* :top-most t)
  (send *workmap* :bottom-most nil)
  (send *desktop-window-menu* :install)
  (send *command-menu* :remove)
  (send *command-menu* :install)
  (send *help-menu* :remove)
  (send *help-menu* :install)
  (when *devel-mode*
        (send *devel-menu* :remove)
        (send *devel-menu* :install))
  (send *desktop-container* :resize)
  (when (= *desktop-layout-state* 2)
        (vista-copyright *run-number* 3))
  (setf *deskup-time* (run-time))
  (send *workmap* :draw-copyright)
  (send *workmap* :redraw)
  (setf *hide-vista* t)
  *desktop-container*)

(provide "systmob1.lsp")
